home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / scainit < prev    next >
Text File  |  1994-03-07  |  3KB  |  94 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. (require 'common-list-functions)    ;to pick up EVERY
  4. (define syncase:andmap comlist:every)
  5.  
  6. ; In Chez Scheme "(syncase:void)" returns an object that is ignored by the
  7. ; REP loop.  It is returned whenever a "nonspecified" value is specified
  8. ; by the standard.  The following should pick up an appropriate value.
  9.  
  10. (define syncase:void
  11.    (let ((syncase:void-object (if #f #f)))
  12.       (lambda () syncase:void-object)))
  13.  
  14. (define syncase:eval-hook slib:eval)
  15.  
  16. (define syncase:error-hook slib:error)
  17.  
  18. (define syncase:new-symbol-hook
  19.   (let ((c 0))
  20.     (lambda (string)
  21.       (set! c (+ c 1))
  22.       (string->symbol
  23.        (string-append string ":Sca" (number->string c))))))
  24.  
  25. (define syncase:put-global-definition-hook #f)
  26. (define syncase:get-global-definition-hook #f)
  27. (let ((*macros* '()))
  28.   (set! syncase:put-global-definition-hook
  29.     (lambda (symbol binding)
  30.       (let ((pair (assq symbol *macros*)))
  31.         (if pair
  32.         (set-cdr! pair binding)
  33.         (set! *macros* (cons (cons symbol binding) *macros*))))))
  34.   (set! syncase:get-global-definition-hook
  35.     (lambda (symbol)
  36.       (let ((pair (assq symbol *macros*)))
  37.         (and pair (cdr pair))))))
  38.  
  39.  
  40. ;;;! expand.pp requires list*
  41. (define (syncase:list* . args)
  42.   (if (null? args)
  43.       '()
  44.       (let ((r (reverse args)))
  45.     (append (reverse (cdr r))
  46.         (car r)            ; Last arg
  47.         '()))))            ; Make sure the last arg is copied
  48.  
  49. (define syntax-error syncase:error-hook)
  50. (define impl-error slib:error)
  51.  
  52. (define base:eval slib:eval)
  53. (define syncase:eval base:eval)
  54. (define macro:eval base:eval)
  55. (define syncase:expand #f)
  56. (define macro:expand #f)
  57. (define (syncase:expand-install-hook expand)
  58.   (set! syncase:eval (lambda (x) (base:eval (expand x))))
  59.   (set! macro:eval syncase:eval)
  60.   (set! syncase:expand expand)
  61.   (set! macro:expand syncase:expand))
  62. ;;; We Need This for bootstrapping purposes:
  63. (define (syncase:load <pathname>)
  64.   (call-with-input-file <pathname>
  65.     (lambda (port)
  66.       (let ((old-load-pathname *load-pathname*))
  67.     (set! *load-pathname* <pathname>)
  68.     (do ((o (read port) (read port)))
  69.         ((eof-object? o))
  70.       (macro:eval o))
  71.     (set! *load-pathname* old-load-pathname)))))
  72. (define macro:load syncase:load)
  73.  
  74. (define syncase:sanity-check #f)
  75. ;;; LOADING THE SYSTEM ITSELF:
  76. (let ((here (lambda (file)
  77.           (in-vicinity (library-vicinity) file)))
  78.       (scmhere (lambda (file)
  79.          (in-vicinity (library-vicinity) file (scheme-file-suffix)))))
  80.   (for-each (lambda (file) (slib:load (here file)))
  81.         '("scaoutp"
  82.           "scaglob"
  83.           "scaexpp"))
  84.   (syncase:expand-install-hook expand-syntax)
  85.   (macro:load (scmhere "scamacr"))
  86.   (set! syncase:sanity-check
  87.     (lambda ()
  88.       (macro:load (scmhere "sca-exp"))
  89.       (syncase:expand-install-hook expand-syntax)
  90.       (macro:load (scmhere "sca-macr")))))
  91.  
  92. (provide 'syntax-case)
  93. (provide 'macro)
  94.